home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / smaltalk / st80_pr4.lha / st80_pre4 / MoDE / TestSNA-Lin.st < prev    next >
Text File  |  1993-07-24  |  38KB  |  1,594 lines
  1. SemanticObject subclass: #BoxCreatorButton
  2.     instanceVariableNames: ''
  3.     classVariableNames: 'SNABoxMiddleButtonMenu '
  4.     poolDictionaries: ''
  5.     category: 'TestSNA-Lin'!
  6.  
  7.  
  8. !BoxCreatorButton methodsFor: 'MMS-initializations'!
  9.  
  10. defaultMMSControllerClass
  11.     "Shan March 9, 1990"
  12.  
  13.     ^PushButtonController!
  14.  
  15. setUpAppearance
  16.     "Shan March 9, 1990"
  17.  
  18.     mode borderWidth: 2.
  19.     mode insideColor: Form white.
  20.     mode extent: 30 @ 30.
  21.     mode highlightDispObj: #inverseHighlight! !
  22.  
  23. !BoxCreatorButton methodsFor: 'controller-msg'!
  24.  
  25. action: e 
  26.     "Ask the user for a rectangle then use that to create the box. Shan 
  27.     March 4, 1990"
  28.  
  29.     | rect box |
  30.     EventQ waitNoButton.
  31.     EventQ disable.
  32.     rect _ Rectangle fromUser.
  33.     EventQ enable.
  34.     box _ SNARectangle new.
  35.     box attachModeTo: target1 mode.
  36.     box mode setUnclippedDisplayBox: rect.
  37.     box mode borderWidth: 1.
  38.     box getName.
  39.     box mode display! !
  40.  
  41. SemanticObject subclass: #SNATreeNode
  42.     instanceVariableNames: 'title parent children leftNeighbor posX posY posP posM '
  43.     classVariableNames: 'DefaultVal NodeSize SNATreeNodeMiddleButtonMenu '
  44.     poolDictionaries: ''
  45.     category: 'TestSNA-Lin'!
  46.  
  47.  
  48. !SNATreeNode methodsFor: 'access'!
  49.  
  50. children
  51.     ^children!
  52.  
  53. children: e
  54.     children addLast: e.!
  55.  
  56. leftNeighbor
  57.     ^leftNeighbor!
  58.  
  59. leftNeighbor: aNode 
  60.     leftNeighbor _ aNode!
  61.  
  62. modifier
  63.     ^posM!
  64.  
  65. modifier: val 
  66.     posM _ val!
  67.  
  68. parent
  69.     ^parent!
  70.  
  71. parent: val 
  72.     parent _ val!
  73.  
  74. posX
  75.  
  76.     ^posX!
  77.  
  78. posX: val
  79.  
  80.     posX _ val.!
  81.  
  82. posY
  83.  
  84.     ^posY!
  85.  
  86. posY: val
  87.  
  88.     posY _ val.!
  89.  
  90. prelim
  91.     ^posP!
  92.  
  93. prelim: val 
  94.     posP _ val! !
  95.  
  96. !SNATreeNode methodsFor: 'middleMenu support'!
  97.  
  98. addNode
  99.     "29 May 1990"
  100.  
  101.     | m name dispObj nameOffset e anode |
  102.     e _ mode controller event.
  103.     anode _ SNATreeNode new.
  104.     EventQ disable.
  105.     FillInTheBlank
  106.         request: 'Type a name. '
  107.         displayAt: e origin
  108.         centered: true
  109.         action: [:resp | name _ resp]
  110.         initialAnswer: ''.
  111.     self children: anode.
  112.     anode target1: target1.
  113.     anode parent: self.
  114.     SNATree new positionTree.
  115.     anode attachModeTo: target1 mode at: anode posX @ anode posY.
  116.     m _ anode mode.
  117.     Cursor wait
  118.         showWhile: 
  119.             [dispObj _ m displayObject.
  120.             nameOffset _ 2 @ 2.
  121.             dispObj relAdd: (name asDisplayText offset: nameOffset).    "m unclippedDisplayBox extent > dispObj boundingBox extent 
  122.             ifFalse: [m setUnclippedDisplayBoxExtent: dispObj 
  123.             boundingBox extent + (nameOffset + m borderWidth * 2)]."
  124.             "m display."
  125.             self treeDisplay.
  126.             EventQ enable]! !
  127.  
  128. !SNATreeNode methodsFor: 'menu access'!
  129.  
  130. middleButtonMenu
  131.     | logicMenu    |
  132.     SNATreeNodeMiddleButtonMenu   isNil
  133.         ifTrue: 
  134.             [logicMenu _ MMSMenu new.
  135.             logicMenu append: (MenuCell selector: #addNode text: 'Add Child').
  136.             logicMenu append: (MenuCell selector: #inspect text: 'Inspect').
  137.             logicMenu append: (MenuCell selector: #hExpand text: 'Follow Hypertext Link').
  138.             SNATreeNodeMiddleButtonMenu _ MMSPopUpMenu createInterfaceFor: logicMenu].
  139.     ^SNATreeNodeMiddleButtonMenu! !
  140.  
  141. !SNATreeNode methodsFor: 'MMS-initializations'!
  142.  
  143. defaultMMSControllerClass
  144.     "Shan March 9, 1990"
  145.  
  146.     ^MidMenuAndMoveController!
  147.  
  148. setUpAppearance
  149.     "29 May 1990"
  150.  
  151.     super setUpAppearance.
  152.     mode extent: 20 @ 20.
  153.     mode borderWidth: 1.
  154.     mode insideColor: Form white.
  155.     mode highlightDispObj:  #thickBorderHighlight! !
  156.  
  157. !SNATreeNode methodsFor: 'initialize-release'!
  158.  
  159. initialize
  160.     super initialize.
  161.     children _ OrderedCollection new.
  162.     parent _ nil.
  163.     leftNeighbor _ nil.
  164.     posY _ 200.
  165.     posX _ 0.
  166.     posP _ 0.
  167.     posM _ 0.! !
  168.  
  169. !SNATreeNode methodsFor: 'layout-support'!
  170.  
  171. leftSibling
  172.     "29 May 1990"
  173.  
  174.     | brothers |
  175.     parent isNil ifTrue: [^nil].
  176.     brothers _  parent children.
  177.     self == brothers first
  178.         ifTrue: [^nil]
  179.         ifFalse: [^brothers before: self]!
  180.  
  181. rightSibling
  182.     "29 May 1990"
  183.  
  184.     | brothers |
  185.     parent isNil ifTrue:[^nil].
  186.     brothers _  parent children.
  187.     self = brothers last
  188.         ifTrue: [^nil]
  189.         ifFalse: [^brothers after: self]!
  190.  
  191. treeDisplay
  192.     "29 May 1990"
  193.  
  194.     
  195.     RootNode attachModeTo: target1 mode at: RootNode posX @ RootNode posY.
  196.     RootNode children do: [:each | self treeDisplay: each].
  197.     target1 mode erase.
  198.     target1 mode display!
  199.  
  200. treeDisplay: aNode 
  201.     "29 May 1990"
  202.  
  203.     aNode children isEmpty
  204.         ifTrue: [aNode attachModeTo: target1 mode at: aNode posX @ aNode posY]
  205.         ifFalse: [aNode children do: [:each | self treeDisplay: each]]! !
  206.  
  207. SemanticObject subclass: #SNAGraph
  208.     instanceVariableNames: ''
  209.     classVariableNames: ''
  210.     poolDictionaries: ''
  211.     category: 'TestSNA-Lin'!
  212. SNAGraph comment:
  213. '"SNAWorkSpace new" will return the semantic object of the backgrounds mode where all the boxes and links reside.   Shan March 9, 1990.
  214. Choose menu by clicking in the function button area:
  215.     1.  Save to file.
  216.     2.  redisplay all object in this diagram.
  217.  
  218. This is designed for IBM SNA Diagram:
  219.     .. Decomposition
  220.     .. Flow'!
  221.  
  222.  
  223. !SNAGraph methodsFor: 'MMS-initializations'!
  224.  
  225. defaultMMSControllerClass
  226.     "Shan March 9, 1990"
  227.  
  228.     ^MidMenuController!
  229.  
  230. defaultModeClass
  231.     "Shan March 9, 1990"
  232.  
  233.     ^ExpandedMode!
  234.  
  235. setUpController
  236.  
  237.     super setUpController!
  238.  
  239. setUpMode
  240.     "Shan March 9, 1990"
  241.  
  242.     super setUpMode.
  243.     mode window: (20 @ 20 extent: 480 @ 400).
  244.     mode resizeStyle: ResizeStyle stickFourCorners! !
  245.  
  246. !SNAGraph methodsFor: 'initialize-release'!
  247.  
  248. initialize
  249.     "Initialize the buttons that create the contents of SNA decomposition 
  250.     diagram. Lin Mar 5, 1990"
  251.  
  252.     | tmp amode aSemObj wind sBar rs |
  253.     super initialize.    "Shan March 9, 1990"
  254.     amode _ ExpandedMode new.
  255.     aSemObj _ SemanticObject new.
  256.     tmp _ BoxCreatorButton new.
  257.     tmp target1: aSemObj.
  258.     tmp attachModeTo: amode at: 0 @ 0.
  259.     tmp _ PointCreatorButton new.
  260.     tmp target1: aSemObj.
  261.     tmp attachModeTo: amode at: 0 @ 100.
  262.     tmp _ PathCreatorButton appearance: (MDisplayObject new absAdd: MMSOpaqueForm trash)
  263.                 pathClass: MMPolyline.
  264.     tmp target1: aSemObj.
  265.     tmp attachModeTo: amode at: 0 @ 30.
  266.     rs _ ResizeStyle new.
  267.     rs originY: #fixed.
  268.     rs originX: #fixed.
  269.     rs extentX: #fixed.
  270.     rs cornerY: #fixed.
  271.     rs matchViewportWindow: true.
  272.     amode borderWidth: 0.
  273.     amode resizeStyle: rs.
  274.     wind _ mode window.
  275.     sBar _ RoamBox extent: 20 @ (wind height - 16) clientMode: aSemObj mode.
  276.     sBar attachModeTo: mode at: wind right - sBar mode viewport width @ wind top.
  277.     rs _ ResizeStyle new.
  278.     rs originY: #fixed.
  279.     rs extentX: #fixed.
  280.     rs cornerX: #fixed.
  281.     rs cornerY: #fixed.
  282.     sBar mode resizeStyle: rs.
  283.     sBar _ RoamBox extent: wind width - 16 - 45 @ 18 clientMode: aSemObj mode.
  284.     rs _ ResizeStyle new.
  285.     rs originX: #fixed.
  286.     rs extentY: #fixed.
  287.     rs cornerX: #fixed.
  288.     rs cornerY: #fixed.
  289.     sBar mode resizeStyle: rs.
  290.     sBar attachModeTo: mode at: 65 @ (wind bottom - sBar mode viewport height).
  291.     aSemObj mode borderWidth: 1.
  292.     aSemObj mode resizeStyle: ResizeStyle stickFourCorners.
  293.     mode
  294.         addSubMode: amode
  295.         at: 20 @ 20
  296.         extent: 45 @ mode viewport height.
  297.     mode
  298.         addSubMode: aSemObj mode
  299.         at: 65 @ 20
  300.         extent: mode viewport width - 45 @ mode viewport height - 18! !
  301. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  302.  
  303. SNAGraph class
  304.     instanceVariableNames: ''!
  305.  
  306.  
  307. !SNAGraph class methodsFor: 'testing'!
  308.  
  309. prototest1
  310.  
  311. "SNAGraph prototest1"
  312. "Linjs,  Feb. 25, 1990"
  313.  
  314.  
  315.     | rMode w  |
  316.     rMode _ RootMode new.
  317.     rMode label: 'MMS Application'.
  318.     rMode minimumSize: 700 @ 630.
  319.      w _ SNAWindow title: 'SNA' origin: 150@50 extent: 500 @ 400.
  320.     w shrinkPosition: 20@20.
  321.     w applicationMode: (SNAGraph new)  mode.
  322.     w attachModeTo: rMode.
  323.     rMode startUp!
  324.  
  325. prototest2
  326.     "SNAWorkSpace prototest2"
  327.     "Linjs, Feb. 25, 1990"
  328.  
  329.     | aFileName tmp |
  330.     aFileName := FillInTheBlank request: 'Load SNA materials from file' initialAnswer: ''.
  331.     aFileName = ''
  332.         ifTrue: 
  333.             [self prototest1.
  334.             ^nil].
  335.     Cursor read showWhile: [tmp := BinaryStorage fromFileNamed: aFileName].
  336.     tmp startUp! !
  337.  
  338. SemanticObject subclass: #PointCreatorButton
  339.     instanceVariableNames: ''
  340.     classVariableNames: ''
  341.     poolDictionaries: ''
  342.     category: 'TestSNA-Lin'!
  343.  
  344.  
  345. !PointCreatorButton methodsFor: 'controller-msg'!
  346.  
  347. action: e 
  348.     "16 May 1990"
  349.  
  350.     | pt position |
  351.     pt _ SNAPoint new.
  352.     EventQ waitNoButton.
  353.     Cursor crossHair showWhile: [position _ EventQ waitClickButton grid: SEESharedStates gridPoint].
  354.     pt attachModeTo: target1 mode.
  355.     pt mode setUnclippedDisplayBoxOrigin: position.
  356.     pt mode display! !
  357.  
  358. !PointCreatorButton methodsFor: 'MMS-initializations'!
  359.  
  360. defaultMMSControllerClass
  361.     "Shan March 9, 1990"
  362.  
  363.     ^PushButtonController!
  364.  
  365. setUpAppearance
  366.     "Shan March 9, 1990"
  367.  
  368.     mode borderWidth: 2.
  369.     mode insideColor: Form gray.
  370.     mode extent: 30 @ 30.
  371.     mode highlightDispObj: #inverseHighlight! !
  372.  
  373. SemanticObject subclass: #SNATree
  374.     instanceVariableNames: ''
  375.     classVariableNames: 'LevelPtr SNATreeMiddleButtonMenu SubtreeSeparation XTopAdjustment YTopAdjustment '
  376.     poolDictionaries: ''
  377.     category: 'TestSNA-Lin'!
  378.  
  379.  
  380. !SNATree methodsFor: 'layout'!
  381.  
  382. apportion: aNode level: aLevel 
  383.     "28 May 1990"
  384.  
  385.     | leftmost neighbor depth ancLeftmost ancNeighbor lModsum rModsum i moveD tempP leftsib portion |
  386.     leftmost _ aNode children first.
  387.     neighbor _ leftmost leftNeighbor.
  388.     depth _ 1.
  389.     [leftmost isNil or: [neighbor isNil]]
  390.         whileFalse: 
  391.             [lModsum _ 0.
  392.             rModsum _ 0.
  393.             ancLeftmost _ leftmost.
  394.             ancNeighbor _ neighbor.
  395.             i _ depth.
  396.             [i < 0]
  397.                 whileFalse: 
  398.                     [ancLeftmost _ ancLeftmost parent.
  399.                     ancNeighbor _ ancNeighbor parent.
  400.                     ancLeftmost isNil ifFalse: [rModsum _ rModsum + ancLeftmost modifier].
  401.                     ancNeighbor isNil ifFalse: [lModsum _ lModsum + ancNeighbor modifier].
  402.                     i _ i - 1].
  403.             moveD _ neighbor prelim + lModsum + 40 + 20 - (leftmost prelim + rModsum).
  404.             moveD > 0
  405.                 ifTrue: 
  406.                     [tempP _ aNode.
  407.                     leftsib _ 0.
  408.                     [tempP isNil or: [tempP == ancNeighbor]]
  409.                         whileFalse: 
  410.                             [leftsib _ leftsib + 1.
  411.                             tempP _ tempP leftSibling].
  412.                     tempP isNil
  413.                         ifFalse: 
  414.                             [portion _ moveD / leftsib.
  415.                             tempP _ aNode.
  416.                             [tempP = ancNeighbor]
  417.                                 whileTrue: 
  418.                                     [tempP prelim: tempP prelim + moveD.
  419.                                     tempP modifier: tempP modifier + moveD.
  420.                                     moveD _ moveD - portion.
  421.                                     tempP _ tempP leftSibling]]
  422.                         ifTrue: [^self]].
  423.             depth _ depth + 1.
  424.             leftmost children isEmpty
  425.                 ifTrue: [leftmost _ self
  426.                                 getLeftmost: aNode
  427.                                 level: 1
  428.                                 depth: depth + 1]
  429.                 ifFalse: [leftmost _ leftmost children first]]!
  430.  
  431. firstWalk: aNode level: aLevel 
  432.     "29 May 1990"
  433.  
  434.     | midPoint leftmost rightmost |
  435.     LevelPtr size < aLevel
  436.         ifTrue: [LevelPtr addLast: aNode]
  437.         ifFalse: 
  438.             [aNode leftNeighbor: (LevelPtr at: aLevel).
  439.             LevelPtr at: aLevel put: aNode].
  440.     aNode modifier: 0.
  441.     aNode children isEmpty
  442.         ifTrue: [aNode leftSibling isNil ifFalse: [aNode prelim: aNode leftSibling prelim + 40 + 20]
  443.                 ifTrue: [aNode prelim: 0]]
  444.         ifFalse: 
  445.             [leftmost _ rightmost _ aNode children first.
  446.             self firstWalk: leftmost level: aLevel + 1.
  447.             [rightmost rightSibling isNil]
  448.                 whileFalse: 
  449.                     [rightmost _ rightmost rightSibling.
  450.                     self firstWalk: rightmost level: aLevel + 1].
  451.             midPoint _ leftmost prelim + rightmost prelim / 2.
  452.             aNode leftSibling isNil
  453.                 ifFalse: 
  454.                     [aNode prelim: aNode leftSibling prelim + 40 + 20.
  455.                     aNode modifier: aNode prelim - midPoint.
  456.                     self apportion: aNode level: aLevel]
  457.                 ifTrue: [aNode prelim: midPoint]]!
  458.  
  459. getLeftmost: aNode level: aLevel depth: depth 
  460.     "28 May 1990"
  461.  
  462.     | rightmost leftmost |
  463.     aLevel >= depth
  464.         ifTrue: [^aNode]
  465.         ifFalse: [aNode children isEmpty
  466.                 ifTrue: [^nil]
  467.                 ifFalse: 
  468.                     [rightmost _ aNode children first.
  469.                     leftmost _ self
  470.                                 getLeftmost: rightmost
  471.                                 level: aLevel + 1
  472.                                 depth: depth.
  473.                     [leftmost isNil and: [rightmost rightSibling ~= nil]]
  474.                         whileTrue: 
  475.                             [rightmost _ rightmost rightSibling.
  476.                             leftmost _ self
  477.                                         getLeftmost: rightmost
  478.                                         level: aLevel + 1
  479.                                         depth: depth].
  480.                     ^leftmost]]!
  481.  
  482. positionTree
  483.  
  484. LevelPtr _ OrderedCollection new.
  485. self firstWalk: RootNode level: 1.
  486. YTopAdjustment _ RootNode posY + RootNode prelim.
  487. XTopAdjustment _ RootNode posX.
  488. self secondWalk: RootNode level: 1 offset: 0.!
  489.  
  490. positionTree: aNode
  491.  
  492. LevelPtr _ OrderedCollection new.
  493. self firstWalk: aNode level: 1.
  494. YTopAdjustment _ aNode posY + aNode prelim.
  495. XTopAdjustment _ aNode posX.
  496. self secondWalk: aNode level: 1 offset: 0.!
  497.  
  498. secondWalk: aNode level: aLevel offset: modsum 
  499.     "24 May 1990"
  500.  
  501.     aNode posY: YTopAdjustment - (aNode prelim + modsum).
  502.     aNode posX: XTopAdjustment + (aLevel -1 * 30).
  503.     aNode children isEmpty ifFalse: [self
  504.             secondWalk: aNode children first
  505.             level: aLevel + 1
  506.             offset: modsum + aNode modifier].
  507.     aNode rightSibling isNil ifFalse: [self
  508.             secondWalk: aNode rightSibling
  509.             level: aLevel 
  510.             offset: modsum]! !
  511.  
  512. !SNATree methodsFor: 'initialize-release'!
  513.  
  514. initialize
  515.     super initialize.
  516.     LevelPtr _ OrderedCollection new.! !
  517.  
  518. !SNATree methodsFor: 'middleMenu support'!
  519.  
  520. createTree
  521.     "29 May 1990"
  522.  
  523.     | m name dispObj nameOffset e  |
  524.     e _ mode controller event.
  525.     RootNode _ SNATreeNode new.
  526.     EventQ disable.
  527.     FillInTheBlank
  528.         request: 'Type a name. '
  529.         displayAt: e origin
  530.         centered: true
  531.         action: [:resp | name _ resp]
  532.         initialAnswer: ''.    
  533.     RootNode target1: self.
  534.     self positionTree: RootNode.
  535.     mode addSubMode: RootNode mode at: (RootNode posX)@(RootNode posY).
  536.     m _ RootNode mode.
  537.     Cursor wait
  538.         showWhile: 
  539.             [dispObj _ m displayObject.
  540.             nameOffset _ 2 @ 2.
  541.             dispObj relAdd: (name asDisplayText offset: nameOffset).
  542.             "m unclippedDisplayBox extent > dispObj boundingBox extent ifFalse: [m setUnclippedDisplayBoxExtent: dispObj boundingBox extent + (nameOffset + m borderWidth * 2)].
  543. "
  544.             m display.    
  545.             EventQ enable].! !
  546.  
  547. !SNATree methodsFor: 'menu access'!
  548.  
  549. middleButtonMenu
  550.     | logicMenu |
  551.     SNATreeMiddleButtonMenu isNil
  552.         ifTrue: 
  553.             [logicMenu _ MMSMenu new.
  554.             logicMenu append: (MenuCell selector: #createTree text: 'Create Tree').
  555.             logicMenu append: (MenuCell selector: #inspect text: 'Inspect').
  556.             logicMenu append: (MenuCell selector: #hExpand text: 'Follow Hypertext Link').
  557.             SNATreeMiddleButtonMenu _ MMSPopUpMenu createInterfaceFor: logicMenu].
  558.     ^SNATreeMiddleButtonMenu! !
  559.  
  560. !SNATree methodsFor: 'MMS-initializations'!
  561.  
  562. defaultMMSControllerClass
  563.     "Shan March 9, 1990"
  564.  
  565.     ^MidMenuAndMoveController!
  566.  
  567. setUpController
  568.     "Shan March 9, 1990"
  569.  
  570.     | d |
  571.     super setUpController.
  572.     d _ mode controller eventResponses deepCopy.  "Shan March 30, 1990"
  573.     d at: #leftButtonDown put: #gridMove:.
  574.     mode controller eventResponses: d! !
  575. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  576.  
  577. SNATree class
  578.     instanceVariableNames: ''!
  579.  
  580.  
  581. !SNATree class methodsFor: 'test'!
  582.  
  583. demo
  584. "SNATree demo"
  585. "29 May 1990"
  586.     
  587.     | rMode w  |
  588.     rMode _ RootMode new.
  589.     rMode label: 'MMS Application'.
  590.     rMode minimumSize: 700 @ 630.
  591.      w _ SNAWindow title: 'SNA' origin: 150@50 extent: 500 @ 400.
  592.     w shrinkPosition: 20@20.
  593.     w applicationMode: (SNATree new)  mode.
  594.     w attachModeTo: rMode.
  595.     rMode startUp! !
  596.  
  597. SemanticObject subclass: #MPolyline
  598.     instanceVariableNames: 'arrowStatus '
  599.     classVariableNames: 'MPolylineMiddleButtonMenu '
  600.     poolDictionaries: ''
  601.     category: 'TestSNA-Lin'!
  602. MPolyline comment:
  603. 'The instance var "arrowStatus" can be:
  604. #none -- no arrow
  605. #begin -- arrow at the beginning
  606. #end -- arrow at the end
  607. #both -- arrow at both ends.
  608. Shan March 7, 1990'!
  609.  
  610.  
  611. !MPolyline methodsFor: 'editing'!
  612.  
  613. checkDots: pt 
  614.     "Do the reshaping and return true when pt falls on one of the dots. 
  615.     Otherwise, return false. Shan March 3, 1990"
  616.  
  617.     | ptCltn index anchorPts newPt |
  618.     ptCltn _ self absPointCltn.
  619.     ptCltn do: [:each | (each - pt) abs <= (2 @ 2) ifTrue: [index _ ptCltn indexOf: each]].
  620.     index isNil
  621.         ifFalse: 
  622.             ["Check for boundary"
  623.             anchorPts _ OrderedCollection new.
  624.             index = 1
  625.                 ifTrue: [anchorPts add: (ptCltn at: 2)]
  626.                 ifFalse: 
  627.                     [anchorPts add: (ptCltn at: index - 1).
  628.                     index = ptCltn size ifFalse: [anchorPts add: (ptCltn at: index + 1)]].    "reshape"
  629.             newPt _ mode controller
  630.                         rubberLineOriginCltn: anchorPts
  631.                         within: nil
  632.                         releaseSelectors: (OrderedCollection with: #leftButtonUp)
  633.                         gridPoint: SEESharedStates gridPoint. "Shan March 16, 1990"
  634.             ptCltn at: index put: newPt.    "Shan March 7, 1990"
  635.             self eraseReshapeDots.
  636.             mode erase.
  637.             self absPointCltn: ptCltn.
  638.             mode display.
  639.             
  640.             self showReshapeDots.
  641.             ^true]
  642.         ifTrue: [^false]!
  643.  
  644. eraseReshapeDots
  645.     "Shan March 3, 1990"
  646.  
  647.     self showReshapeDots!
  648.  
  649. showReshapeDots
  650.     "Shan March 3, 1990"
  651.  
  652.     |   rect |
  653.     self absPointCltn do: 
  654.         [:each | 
  655.         rect _ each - (2@2) extent: 5@5.
  656.         Display reverse: rect]! !
  657.  
  658. !MPolyline methodsFor: 'controller-msg'!
  659.  
  660. action: e 
  661.     "Put up the reshape dots and move image. Shan March 3, 1990"
  662.  
  663.     | active event |
  664.     mode controller moveImage.
  665.     self showReshapeDots.
  666.     active _ true.
  667.     [active]
  668.         whileTrue: 
  669.             [event _ EventQ nextWithCursorMoveCompressed.
  670.             event selector == #leftButtonDown ifTrue: ["Check dots"
  671.                 (self checkDots: event origin)
  672.                     ifFalse: ["Check move"
  673.                         (mode interestedIn: event)
  674.                             ifTrue: 
  675.                                 [self eraseReshapeDots.
  676.                                 mode controller moveImageGridTo: SEESharedStates gridPoint 
  677.  
  678. .    "Shan March 19, 1990"                        self showReshapeDots]
  679.                             ifFalse: ["terminate"
  680.                                 active _ false]]]].
  681.     
  682.     self eraseReshapeDots.
  683.     "self buildLine: self absPointCltn."! !
  684.  
  685. !MPolyline methodsFor: 'middleMenu support'!
  686.  
  687. hExpand
  688.     "Expand the hypertext link. Shan March 20, 1990"
  689.  
  690.     | pView aPollingEnvMode w |
  691.     pView _ SNATextView  "Shan April 2, 1990"
  692.                 on: (SNAText fileName: 'SNAdoc/text1')
  693.                 aspect: #text
  694.                 change: #acceptText:from:
  695.                 menu: #textMenu.
  696.     pView borderWidth: (1@1 corner: 1@1).  "Shan March 21, 1990"
  697.     aPollingEnvMode _ PollingEnvMode new "extent: 450 @ 200".
  698.     aPollingEnvMode addSubView: pView.
  699.     w _ SNAWindow
  700.                 title: 'Path Control'
  701.                 origin: 30 @ 275
  702.                 extent: 500 @ 300.
  703.     w shrinkPosition: 20 @ 220.
  704.     w applicationMode: aPollingEnvMode.
  705.     w attachModeTo: mode topMode.
  706.     w initialOpen.
  707.     Display zoom: mode unclippedDisplayBox to: w mode unclippedDisplayBox.
  708.     w mode display! !
  709.  
  710. !MPolyline methodsFor: 'menu access'!
  711.  
  712. middleButtonMenu
  713.     "Shan March 20, 1990"
  714.  
  715.     | logicMenu |
  716.     MPolylineMiddleButtonMenu isNil
  717.         ifTrue: 
  718.             [logicMenu _ MMSMenu new.
  719.             logicMenu append: (MenuCell selector: #hExpand text: 'Follow Hypertext Link').
  720.             MPolylineMiddleButtonMenu _ MMSPopUpMenu createInterfaceFor: logicMenu].
  721.     ^MPolylineMiddleButtonMenu! !
  722.  
  723. !MPolyline methodsFor: 'MMS-initializations'!
  724.  
  725. defaultModeClass
  726.     "Shan February 26, 1990"
  727.     
  728.     ^FixedImageMode!
  729.  
  730. setUpController
  731.     "Shan March 20, 1990"
  732.  
  733.     | ctrl erDict |
  734.     super setUpController.
  735.     ctrl _ mode controller.
  736.     erDict _ ctrl eventResponses deepCopy.
  737.     erDict at: #leftButtonDown put: #action:.
  738.     erDict at: #middleButtonDown put: #expandMiddleMenu.
  739.     ctrl eventResponses: erDict! !
  740.  
  741. !MPolyline methodsFor: 'formating'!
  742.  
  743. absPointCltn: aCltnOfPts 
  744.     "The points are in screen coordinates. This can only be used when 
  745.     superMode exists. Shan February 1990"
  746.  
  747.     | bBox | 
  748.     bBox _ self buildLine: aCltnOfPts.
  749.     mode setUnclippedDisplayBoxOrigin: bBox origin!
  750.  
  751. brushForm
  752.      ^SEESharedStates brushForm.!
  753.  
  754. brushForm: aForm
  755.     SEESharedStates brushForm: aForm.!
  756.  
  757. buildLine: aCltnOfPts 
  758.     "Set up the display object and return the bounding box for the 
  759.     polyline. All points in the path will be translated relative to the 
  760.     bounding box of the path. The bounding box is returned. Shan 
  761.     February 26, 1990"
  762.  
  763.     | dispObj line bBox arrowForm vector |
  764.     dispObj _ mode displayObject.
  765.     dispObj clear.
  766.     line _ MMSLinearFit new.
  767.     line form: self brushForm.
  768.     aCltnOfPts do: [:each | line add: each].
  769.     bBox _ line boundingBox.
  770.     dispObj absAdd: line.
  771.     arrowStatus == #end
  772.         ifTrue: 
  773.             ["Arrows. Shan March 7, 1990"
  774.             vector _ aCltnOfPts last - (aCltnOfPts before: aCltnOfPts last).
  775.             arrowForm _ MMSOpaqueForm arrows closestAtVector: vector.
  776.             dispObj absAdd: arrowForm.
  777.             arrowForm offset: aCltnOfPts last - 8.
  778.             bBox _ bBox merge: arrowForm boundingBox].
  779.     dispObj translateBy: bBox origin * -1.
  780.     dispObj makeAbsoluteFaster.
  781.     ^bBox!
  782.  
  783. pointCltn: aCltnOfPts 
  784.     "The points are relative to the will-be superMode. Shan February 26, 
  785.     1990"
  786.  
  787.     | bBox |
  788.     bBox _ self buildLine: aCltnOfPts.
  789.     mode origin: bBox origin extent: bBox extent! !
  790.  
  791. !MPolyline methodsFor: 'accessing'!
  792.  
  793. absPointCltn
  794.     "Return the collection of points that form the polyline in screen 
  795.     coordinates. This works only when this polyline has a rootMode. 
  796.     Shan February 26, 1990"
  797.  
  798.     | line cltn dBoxOrg |
  799.     line _ mode displayObject contents first.
  800.     cltn _ OrderedCollection new.
  801.     dBoxOrg _ mode unclippedDisplayBox origin.
  802.     1 to: line size do: [:n | cltn add: (line at: n)
  803.                 + dBoxOrg].
  804.     ^cltn!
  805.  
  806. arrowStatus
  807.     "Shan March 7, 1990"
  808.  
  809.     ^arrowStatus!
  810.  
  811. arrowStatus: aSymbol
  812.     "Shan March 7, 1990"
  813.  
  814.     arrowStatus _ aSymbol! !
  815.  
  816. !MPolyline methodsFor: 'initialize-release'!
  817.  
  818. initialize
  819.     "Shan March 7, 1990"
  820.  
  821.     super initialize.
  822.     arrowStatus _ #none! !
  823. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  824.  
  825. MPolyline class
  826.     instanceVariableNames: ''!
  827.  
  828.  
  829. !MPolyline class methodsFor: 'testing'!
  830.  
  831. test1
  832.     "self test1"
  833.     "Shan March 3, 1990"
  834.  
  835.     | rMode bt |
  836.     rMode _ RootMode new.
  837.     bt _ PathCreatorButton appearance: (MDisplayObject new absAdd: MMSOpaqueForm trash) pathClass: MPolyline.
  838.     bt attachModeTo: rMode at: 10@10.
  839.     rMode semanticObject: SemanticObject new.
  840.     bt target1: rMode semanticObject.
  841.     rMode startUp!
  842.  
  843. test2
  844.     "self test2"
  845.     "Shan March 3, 1990"
  846.  
  847.     | rMode bt |
  848.     rMode _ RootMode new.
  849.     bt _ PathCreatorButton appearance: (MDisplayObject new absAdd: MMSOpaqueForm trash) pathClass: MMPolyline.
  850.     bt attachModeTo: rMode at: 10@10.
  851.     rMode semanticObject: SemanticObject new.
  852.     bt target1: rMode semanticObject.
  853.     rMode startUp! !
  854.  
  855. MPolyline subclass: #MMPolyline
  856.     instanceVariableNames: 'lineWidth lineColor '
  857.     classVariableNames: 'SNAMMPolyMiddleButtonMenu '
  858.     poolDictionaries: ''
  859.     category: 'TestSNA-Lin'!
  860.  
  861.  
  862. !MMPolyline methodsFor: 'MMS-initializations'!
  863.  
  864. defaultMMSControllerClass
  865.     "Shan March 3, 1990"
  866.  
  867.     ^MidMenuController! !
  868.  
  869. !MMPolyline methodsFor: 'initialize-release'!
  870.  
  871. initialize
  872.     ""
  873.  
  874.     super initialize.
  875.     arrowStatus _ #none.
  876.     lineWidth _ 1.
  877.     lineColor _ Form black.! !
  878.  
  879. !MMPolyline methodsFor: 'attribute support'!
  880.  
  881. black
  882.     ""
  883.     |  |
  884.     lineColor _ Form black.!
  885.  
  886. darkGray
  887.     
  888.     lineColor _ Form darkGray.!
  889.  
  890. four
  891.     ""
  892.     |  |
  893.     lineWidth _ 4.
  894.     mode erase.
  895.     self buildLine: self absPointCltn.
  896.     mode display.!
  897.  
  898. gray
  899.     
  900.     lineColor _ Form gray.!
  901.  
  902. lightGray
  903.     
  904.     lineColor _ Form lightGray.!
  905.  
  906. one
  907.     ""
  908.     |  |
  909.     lineWidth _ 1.
  910.     mode erase.
  911.     self buildLine: self absPointCltn.
  912.     mode display.!
  913.  
  914. three
  915.     ""
  916.     |  |
  917.     lineWidth _ 3.
  918.     mode erase.
  919.     self buildLine: self absPointCltn.
  920.     mode display.!
  921.  
  922. two
  923.     ""
  924.     |  |
  925.     lineWidth _ 2.
  926.     mode erase.
  927.     self buildLine: self absPointCltn.
  928.     mode display.!
  929.  
  930. veryDarkGray
  931.     
  932.     lineColor _ Form veryDarkGray.!
  933.  
  934. veryLightGray
  935.     
  936.     lineColor _ Form veryLightGray.!
  937.  
  938. white
  939.  
  940.     lineColor _ Form white.!
  941.  
  942. zero
  943.     ""
  944.     |  |
  945.     lineWidth _ 0.
  946.     mode erase.
  947.     self buildLine: self absPointCltn.
  948.     mode display.! !
  949.  
  950. !MMPolyline methodsFor: 'menu-support'!
  951.  
  952. changeArrow
  953.     self arrowStatus == #none
  954.         ifTrue: [self arrowStatus: #end]
  955.         ifFalse: [self arrowStatus: #none].
  956.     mode erase.
  957.     self buildLine: self absPointCltn.
  958.     mode display.!
  959.  
  960. editLineColor
  961.  
  962.     MenuTestWorkSpace colorMapMenu startUpOnSemanticObject: self.
  963.     
  964.     self buildLine: self absPointCltn.
  965.     mode erase.
  966.     mode display.!
  967.  
  968. hCreate
  969.     "Shan 31 May 1990"
  970.  
  971.     SNACurrentStates
  972.         startLinkFrom: self 
  973.         at: mode unclippedDisplayBox center
  974.         rootMode: mode topMode!
  975.  
  976. hExpand
  977.     "Shan 31 May 1990"
  978.  
  979.     SNACurrentStates expandLinkFrom: self sourceBox: mode unclippedDisplayBox!
  980.  
  981. removeLine
  982.  
  983.     self clearAllConnections.
  984.     mode erase.
  985.     mode removeFromSuperMode.
  986.     mode release!
  987.  
  988. resizeLine
  989.  
  990.     | active event |
  991.     "mode controller moveImage."
  992.     self showReshapeDots.
  993.     active _ true.
  994.     [active]
  995.         whileTrue: 
  996.             [event _ EventQ nextWithCursorMoveCompressed.
  997.             event selector == #leftButtonDown ifTrue: ["Check dots"
  998.                 (self checkDots: event origin)
  999.                     ifFalse: ["Check move"
  1000.                         (mode interestedIn: event)
  1001.                             ifTrue: 
  1002.                                 [self eraseReshapeDots.
  1003.                                 mode controller moveImageGridTo: SEESharedStates gridPoint.    
  1004.                                 self showReshapeDots]
  1005.                             ifFalse: ["terminate"
  1006.                                 active _ false. ]]]].
  1007.     self eraseReshapeDots.
  1008.     self buildLine: self absPointCltn.! !
  1009.  
  1010. !MMPolyline methodsFor: 'menu access'!
  1011.  
  1012. middleButtonMenu
  1013.     | logicMenu  subM |
  1014.     SNAMMPolyMiddleButtonMenu  isNil
  1015.         ifTrue: 
  1016.             [logicMenu _ MMSMenu new.
  1017.             logicMenu append: (MenuCell selector: #changeArrow text: 'Change Arrow').
  1018.             logicMenu append: (MenuCell selector: #editLineColor text: 'Line Color').
  1019.             logicMenu append: (subM _ MenuCell selector: nil text: 'Line Width').
  1020.             subM append: MenuTestWorkSpace lineWidthLogicMenu.
  1021.             logicMenu append: (MenuCell selector: #resizeLine text: 'Reshape').
  1022.             logicMenu append: (MenuCell selector: #removeLine text: 'Remove').
  1023.             logicMenu append: (MenuCell selector: #hExpand text: 'Follow Hypertext Link').
  1024.             logicMenu append: (MenuCell selector: #hCreate text: 'Create Hypertext Link').            SNAMMPolyMiddleButtonMenu _ MMSPopUpMenu createInterfaceFor: logicMenu].
  1025.     ^SNAMMPolyMiddleButtonMenu! !
  1026.  
  1027. !MMPolyline methodsFor: 'formating'!
  1028.  
  1029. buildLine: aCltnOfPts 
  1030.     "Set up the display object and return the bounding box for the 
  1031.     polyline. All points in the path will be translated relative to the 
  1032.     bounding box of the path. The bounding box is returned. Shan 
  1033.     February 26, 1990"
  1034.  
  1035.     | dispObj line bBox arrowForm vector aForm |
  1036.     dispObj _ mode displayObject.
  1037.     dispObj clear.
  1038.     line _ MMSLinearFit new.
  1039.     aForm _ Form new extent: lineWidth asPoint.
  1040.     aForm  black.
  1041.     line form: aForm.
  1042.     line color: lineColor.
  1043.     aCltnOfPts do: [:each | line add: each].
  1044.     bBox _ line boundingBox.
  1045.     dispObj absAdd: line.
  1046.     arrowStatus == #end
  1047.         ifTrue: 
  1048.             ["Arrows. Shan March 7, 1990"
  1049.             vector _ aCltnOfPts last - (aCltnOfPts before: aCltnOfPts last).
  1050.             arrowForm _ MMSOpaqueForm arrows closestAtVector: vector.
  1051.             dispObj absAdd: arrowForm.
  1052.             arrowForm offset: aCltnOfPts last - 8 .
  1053.             bBox _ bBox merge: arrowForm boundingBox].
  1054.     dispObj translateBy: bBox origin * -1.
  1055.     dispObj makeAbsoluteFaster.
  1056.     ^bBox! !
  1057.  
  1058. !MMPolyline methodsFor: 'accessing'!
  1059.  
  1060. absPointCltn
  1061.     "Return the collection of points that form the polyline in screen 
  1062.     coordinates. This works only when this polyline has a rootMode. 
  1063.     Shan February 26, 1990"
  1064.  
  1065.     | line cltn dBoxOrg |
  1066.     line _ mode displayObject contents first.
  1067.     cltn _ OrderedCollection new.
  1068.     dBoxOrg _ mode unclippedDisplayBox origin.
  1069.     1 to: line size do: [:n | cltn add: (line at: n)
  1070.                 + dBoxOrg].
  1071.     ^cltn!
  1072.  
  1073. displayLine: aCltnOfPts
  1074.  
  1075.     | subdispObj sourcePt  vector arrowForm bBox |
  1076.     mode erase.
  1077.     subdispObj _ MDisplayObject new.
  1078.     sourcePt _ nil.
  1079.     aCltnOfPts  do: 
  1080.         [:each | 
  1081.         sourcePt isNil ifFalse: [subdispObj absAdd: (MMSLine
  1082.                     from: sourcePt
  1083.                     to: each
  1084.                     width: lineWidth
  1085.                     color: lineColor)].
  1086.         sourcePt _ each].
  1087.     bBox _ subdispObj boundingBox.
  1088.     arrowStatus == #end
  1089.         ifTrue: 
  1090.             ["Arrows. Shan March 7, 1990"
  1091.             vector _ aCltnOfPts last - (aCltnOfPts before: aCltnOfPts last).
  1092.             arrowForm _ MMSOpaqueForm arrows closestAtVector: vector.
  1093.              subdispObj absAdd: arrowForm.
  1094.             arrowForm offset: aCltnOfPts last - 8.
  1095.             bBox _ bBox merge: arrowForm boundingBox].
  1096.     
  1097.     subdispObj displayAt: bBox origin.! !
  1098.  
  1099. SemanticObject subclass: #SNAPoint
  1100.     instanceVariableNames: 'filled position '
  1101.     classVariableNames: 'SNAPointMiddleButtonMenu '
  1102.     poolDictionaries: ''
  1103.     category: 'TestSNA-Lin'!
  1104.  
  1105.  
  1106. !SNAPoint methodsFor: 'menu access'!
  1107.  
  1108. middleButtonMenu
  1109.     | logicMenu   |
  1110.     SNAPointMiddleButtonMenu   isNil
  1111.         ifTrue: 
  1112.             [logicMenu _ MMSMenu new.
  1113.             "logicMenu append: (MenuCell selector: #editMode text: 'Change Appearance').
  1114. "            logicMenu append: (MenuCell selector: #remove text: 'Remove').
  1115. "            logicMenu append: (MenuCell selector: #hExpand text: 'Follow Hypertext Link')."
  1116.             SNAPointMiddleButtonMenu _ MMSPopUpMenu createInterfaceFor: logicMenu].
  1117.     ^SNAPointMiddleButtonMenu! !
  1118.  
  1119. !SNAPoint methodsFor: 'menu-support'!
  1120.  
  1121. editMode
  1122.     | circle |
  1123.     mode erase.
  1124.     mode removeFromSuperMode.
  1125.     
  1126.     circle _ MMSCircle new.
  1127.     filled == #yes ifTrue: [ filled _ #no.
  1128.                             circle form: (Form extent: 1 @ 1) black.
  1129.                             circle radius: 3.
  1130.                             circle center: 3 @ 3.
  1131.                             ]
  1132.                 ifFalse: [ filled _ #yes.
  1133.                         circle form: (Form extent: 2 @ 2) black.
  1134.                             circle radius: 1.
  1135.                             circle center: 3 @ 3.].
  1136.  
  1137.         mode displayObject absAdd: circle.        
  1138.         "mode erase."
  1139.         mode  display.!
  1140.  
  1141. remove
  1142.     self clearAllConnections.
  1143.     mode erase.
  1144.     mode removeFromSuperMode.
  1145.     mode release! !
  1146.  
  1147. !SNAPoint methodsFor: 'MMS-initializations'!
  1148.  
  1149. defaultMMSControllerClass
  1150.     "16 May 1990"
  1151.  
  1152.     ^MidMenuAndMoveController!
  1153.  
  1154. setUpController
  1155.     "Shan March 9, 1990"
  1156.  
  1157.     | d |
  1158.     super setUpController.
  1159.     d _ mode controller eventResponses deepCopy.  "Shan March 30, 1990"
  1160.     d at: #leftButtonDown put: #gridMove:.
  1161.     mode controller eventResponses: d!
  1162.  
  1163. setUpMode
  1164. "SNAPoint setUpMode"
  1165.     super setUpMode.
  1166.     mode extent: 7@7! !
  1167.  
  1168. !SNAPoint methodsFor: 'initialize-release'!
  1169.  
  1170. initialize
  1171.     | circle |
  1172.     super initialize.
  1173.     filled _ #no.
  1174.     circle _ MMSCircle new.
  1175.     circle form: (Form extent: 1 @ 1) black.
  1176.                             circle radius: 3.
  1177.                             circle center: 3 @ 3.
  1178.     mode displayObject absAdd: circle.! !
  1179.  
  1180. !SNAPoint methodsFor: 'access'!
  1181.  
  1182. position: aPoint
  1183.  
  1184.     position _ aPoint! !
  1185.  
  1186. !SNAPoint methodsFor: 'controller-msg'!
  1187.  
  1188. gridMove: e 
  1189.     "Shan March 19, 1990"
  1190.  
  1191.     mode controller moveImageGridTo: SEESharedStates gridPoint! !
  1192.  
  1193. SemanticObject subclass: #PathCreatorButton
  1194.     instanceVariableNames: 'pathClass '
  1195.     classVariableNames: 'SharedBrushForm '
  1196.     poolDictionaries: ''
  1197.     category: 'TestSNA-Lin'!
  1198. PathCreatorButton comment:
  1199. 'The mode is the button on the pallet that shows the icon of the path.  When the button is clicked, this semantic object collect a set of point for creating the path.  Shan March 3, 1990'!
  1200.  
  1201.  
  1202. !PathCreatorButton methodsFor: 'point collecting'!
  1203.  
  1204. getPtCltn
  1205.     "This is the main method. It interacts with the user and provides 
  1206.     feedback. Shan March 3, 1990"
  1207.  
  1208.     | ptCltn prePt newPt |
  1209.     Cursor crossHair
  1210.         showWhile: 
  1211.             [ptCltn _ OrderedCollection new.    "Get the first point"
  1212.             "Shan March 16, 1990"
  1213.             ptCltn add: (EventQ waitClickButton grid: SEESharedStates gridPoint).
  1214.             
  1215.             ["Collect the rest of the point"
  1216.             prePt _ ptCltn last.
  1217.             newPt _ mode controller
  1218.                         rubberLineOriginCltn: (OrderedCollection with: prePt)
  1219.                         within: nil
  1220.                         releaseSelectors: (OrderedCollection with: #leftButtonDown)
  1221.                         gridPoint: SEESharedStates gridPoint.
  1222.             newPt ~= prePt
  1223.                 ifTrue: 
  1224.                     [ptCltn add: newPt.
  1225.                     Display
  1226.                         drawLine: PathCreatorButton sharedBrushForm
  1227.                         from: prePt
  1228.                         to: newPt
  1229.                         clippingBox: Display boundingBox
  1230.                         rule: Form over
  1231.                         mask: Form black].
  1232.             newPt ~= prePt] whileTrue].
  1233.     ^ptCltn! !
  1234.  
  1235. !PathCreatorButton methodsFor: 'controller-msg'!
  1236.  
  1237. action: e 
  1238.     "Enter the point collection mode.  Shan March 3, 1990"
  1239.  
  1240.     | ptCltn path |
  1241.     ptCltn _ self getPtCltn.
  1242.     path _ pathClass new.
  1243.     path arrowStatus: #end.
  1244.     "target1 mode is the background of the path."
  1245.     path attachModeTo: target1 mode.
  1246.     path absPointCltn: ptCltn.
  1247.     path mode display! !
  1248.  
  1249. !PathCreatorButton methodsFor: 'MMS-initializations'!
  1250.  
  1251. defaultMMSControllerClass
  1252.     "Shan March 9, 1990"
  1253.  
  1254.     ^PushButtonController!
  1255.  
  1256. setUpAppearance
  1257.     "Shan March 9, 1990"
  1258.  
  1259.     mode highlightDispObj: #inverseHighlight! !
  1260.  
  1261. !PathCreatorButton methodsFor: 'private'!
  1262.  
  1263. appearance: aDispObj pathClass: aClass 
  1264.     "Shan March 3, 1990"
  1265.  
  1266.     pathClass _ aClass.
  1267.     mode displayObject: aDispObj.
  1268.     mode resizeToFitDisplayObject! !
  1269. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  1270.  
  1271. PathCreatorButton class
  1272.     instanceVariableNames: ''!
  1273.  
  1274.  
  1275. !PathCreatorButton class methodsFor: 'instance creation'!
  1276.  
  1277. appearance: aDispObj pathClass: aClass 
  1278.     "Create the button that when pushed, generate an instance of the 
  1279.     path. 'target1' is the destination mode's semantic object. Shan 
  1280.     March 3, 1990"
  1281.  
  1282.     ^self new appearance: aDispObj pathClass: aClass! !
  1283.  
  1284. !PathCreatorButton class methodsFor: 'accessing'!
  1285.  
  1286. sharedBrushForm
  1287.     "Shan March 3, 1990"
  1288.  
  1289.     ^SharedBrushForm!
  1290.  
  1291. sharedBrushForm: aForm
  1292.     "Shan March 3, 1990"
  1293.  
  1294.     SharedBrushForm _ aForm! !
  1295.  
  1296. !PathCreatorButton class methodsFor: 'class initialization'!
  1297.  
  1298. initialize
  1299.     "self initialize"
  1300.     "Shan March 3, 1990"
  1301.  
  1302.     SharedBrushForm _ (Form new extent: 1@1) black.! !
  1303.  
  1304. PathCreatorButton initialize!
  1305.  
  1306.  
  1307. TextLabel subclass: #SNARectangle
  1308.     instanceVariableNames: 'centeredText '
  1309.     classVariableNames: 'SNARecMiddleButtonMenu '
  1310.     poolDictionaries: ''
  1311.     category: 'TestSNA-Lin'!
  1312.  
  1313.  
  1314. !SNARectangle methodsFor: 'menu-support'!
  1315.  
  1316. centerText
  1317.     mode erase.
  1318.     self centerText1: text.
  1319.     mode display.
  1320.     centeredText _ #yes!
  1321.  
  1322. duplicateBox
  1323.     | newProto newProtoMode newPos |
  1324.     Cursor wait
  1325.         showWhile: 
  1326.             [newProto _ self duplicate.
  1327.             newProto attachModeTo: mode superMode absAt: EventQ mousePoint - (newProto mode displayBox extent / 2).
  1328.             newProtoMode _ newProto mode.
  1329.             newProtoMode display].
  1330.     newPos _ newProtoMode controller moveImageFB.
  1331.     newPos notNil
  1332.         ifTrue: 
  1333.             [newProto attachModeTo: mode superMode absAt: newPos.
  1334.             newProtoMode display]!
  1335.  
  1336. editBorderColor
  1337.     borderOrinside _ #borderColor:.
  1338.     MenuTestWorkSpace colorMapMenu startUpOnSemanticObject: self.
  1339.     mode erase.
  1340.     mode display!
  1341.  
  1342. editInsideColor
  1343.     "Shan July 31, 1989"
  1344.  
  1345.     borderOrinside _ #insideColor:.
  1346.     MenuTestWorkSpace colorMapMenu startUpOnSemanticObject: self.
  1347.     mode erase.
  1348.     mode display!
  1349.  
  1350. editName
  1351.     self getName.
  1352.     mode erase.
  1353.      mode superView display.!
  1354.  
  1355. hCreate
  1356.     "Shan 29 May 1990"
  1357.  
  1358.     SNACurrentStates
  1359.         startLinkFrom: self string
  1360.         at: mode unclippedDisplayBox center
  1361.         rootMode: mode topMode!
  1362.  
  1363. hExpand
  1364.     "Expand the hypertext link. Shan March 20, 1990"
  1365.     "Shan 29 May 1990"
  1366.  
  1367.     SNACurrentStates expandLinkFrom: self string sourceBox: mode unclippedDisplayBox!
  1368.  
  1369. remove
  1370.     self clearAllConnections.
  1371.     mode erase.
  1372.     mode removeFromSuperMode.
  1373.     mode release!
  1374.  
  1375. resizeBox
  1376.     mode controller bottomRightMoved.
  1377.     ceteredText == #yes ifTrue:[self centerText1: text].
  1378.     mode erase.
  1379.     mode display! !
  1380.  
  1381. !SNARectangle methodsFor: 'attribute support'!
  1382.  
  1383. black
  1384.     ""
  1385.  
  1386.     mode perform: borderOrinside with: Form black!
  1387.  
  1388. darkGray
  1389.     ""
  1390.  
  1391.     mode perform: borderOrinside with: Form darkGray!
  1392.  
  1393. four
  1394.     
  1395.     mode borderWidth: 4.
  1396.     mode display!
  1397.  
  1398. gray
  1399.     "Shan July 31, 1989"
  1400.  
  1401.     mode perform: borderOrinside with: Form gray!
  1402.  
  1403. lightGray
  1404.     ""
  1405.  
  1406.     mode perform: borderOrinside with: Form lightGray!
  1407.  
  1408. one
  1409.     
  1410.     mode borderWidth: 1.
  1411.     mode display!
  1412.  
  1413. three
  1414.     
  1415.     mode borderWidth: 3.
  1416.     mode display!
  1417.  
  1418. transparent
  1419.     "Shan July 31, 1989"
  1420.  
  1421.     borderOrinside = #borderColor: ifTrue: [^self].
  1422.     mode perform: borderOrinside with: nil!
  1423.  
  1424. two
  1425.     
  1426.     mode borderWidth: 2.
  1427.     mode display!
  1428.  
  1429. veryDarkGray
  1430.     ""
  1431.  
  1432.     mode perform: borderOrinside with: Form veryDarkGray!
  1433.  
  1434. veryLightGray
  1435.     ""
  1436.  
  1437.     mode perform: borderOrinside with: Form veryLightGray!
  1438.  
  1439. white
  1440.     ""
  1441.  
  1442.     mode perform: borderOrinside with: Form white!
  1443.  
  1444. zero
  1445.     
  1446.     mode borderWidth: 0.
  1447.     mode display! !
  1448.  
  1449. !SNARectangle methodsFor: 'MMS-initializations'!
  1450.  
  1451. defaultMMSControllerClass
  1452.     "Shan March 9, 1990"
  1453.  
  1454.     ^MidMenuAndMoveController!
  1455.  
  1456. setUpController
  1457.     "Shan March 9, 1990"
  1458.  
  1459.     | d |
  1460.     super setUpController.
  1461.     d _ mode controller eventResponses deepCopy.  "Shan March 30, 1990"
  1462.     d at: #leftButtonDown put: #gridMove:.
  1463.     mode controller eventResponses: d! !
  1464.  
  1465. !SNARectangle methodsFor: 'controller-msg'!
  1466.  
  1467. gridMove: e 
  1468.     "Shan March 19, 1990"
  1469.  
  1470.     mode controller moveFrameGridTo: SEESharedStates gridPoint! !
  1471.  
  1472. !SNARectangle methodsFor: 'access'!
  1473.  
  1474. centerText1: aText
  1475.  
  1476.     |    aParagraph |
  1477.     text _ aText.
  1478.     "messageView _ DisplayTextView new editParagraph: aText asParagraph.
  1479.     messageView borderWidthLeft: 0 right: 0 top: 0 bottom: 0.
  1480.     messageView insideColor: Form white.
  1481.     messageView controller: NoController new.
  1482.     mode addSubView: messageView.
  1483.     messageView centered."
  1484.     "messageView translateBy: (mode inverseDisplayTransform: mode insetDisplayBox origin)."
  1485.     mode displayObject clear.
  1486.     aParagraph _ text asParagraph.
  1487.     mode displayObject absAdd: (aParagraph align: aParagraph boundingBox center
  1488.                 with: self mode getWindow center).!
  1489.  
  1490. centerText: aText
  1491.  
  1492.     | displayText |
  1493.     text _ aText.
  1494.     displayText _ aText asDisplayText.
  1495.     mode displayObject clear.
  1496.     mode displayObject relAdd: displayText.
  1497.     self checkSize!
  1498.  
  1499. checkSize
  1500.  
  1501.     mode resizeToFitDisplayObject! !
  1502.  
  1503. !SNARectangle methodsFor: 'attribute'!
  1504.  
  1505. getName
  1506.     | newBlank aText fillinView savedArea aParagraph |
  1507.     newBlank _ FillInTheBlank new initialize.
  1508.     newBlank action: [:answer | aText _ answer].
  1509.     fillinView _ SpecialFTBlankView
  1510.                 on: newBlank
  1511.                 message: 'box name'
  1512.                 displayAt: Sensor cursorPoint
  1513.                 centered: true
  1514.                 useCRController: false.
  1515.     savedArea _ Form fromDisplay: fillinView displayBox.
  1516.     EventQ disable.
  1517.     fillinView window: (0 @ 0 extent: 200 @ 100).
  1518.     fillinView display.
  1519.     fillinView controller centerCursorInView.
  1520.     fillinView controller startUp.
  1521.     fillinView release.
  1522.     EventQ enable.
  1523.     savedArea displayOn: Display at: fillinView viewport topLeft.
  1524.     centeredText == #yes
  1525.         ifTrue: [self centerText1: aText]
  1526.         ifFalse: 
  1527.             [text _ aText.
  1528.             mode displayObject clear.
  1529.             aParagraph _ text asParagraph.
  1530.             mode displayObject absAdd: aParagraph]! !
  1531.  
  1532. !SNARectangle methodsFor: 'menu access'!
  1533.  
  1534. middleButtonMenu
  1535.     | logicMenu mEditM subM |
  1536.     SNARecMiddleButtonMenu isNil
  1537.         ifTrue: 
  1538.             [logicMenu _ MMSMenu new.
  1539.             logicMenu append: (MenuCell selector: #duplicateBox text: 'Duplicate').
  1540.             logicMenu append: (MenuCell selector: #centerText text: 'Center Text').
  1541.             logicMenu append: (MenuCell selector: #editName text: 'Edit Name').
  1542.             logicMenu append: (mEditM _ MenuCell selector: #editMode text: 'Edit Appearance').
  1543.             mEditM append: (MenuCell selector: #editInsideColor text: 'Inside Color').
  1544.             mEditM append: (MenuCell selector: #editBorderColor text: 'Border Color').
  1545.             mEditM append: (subM _ MenuCell selector: nil text: 'Border Width').
  1546.             subM append: MenuTestWorkSpace lineWidthLogicMenu.
  1547.             mEditM append: (MenuCell selector: #resizeBox text: 'Resize').
  1548.             logicMenu append: (MenuCell selector: #remove text: 'Remove').
  1549.             logicMenu append: (MenuCell selector: #hExpand text: 'Follow Hypertext Link').
  1550.             logicMenu append: (MenuCell selector: #hCreate text: 'Create Hypertext Link').
  1551.             SNARecMiddleButtonMenu _ MMSPopUpMenu createInterfaceFor: logicMenu].
  1552.     ^SNARecMiddleButtonMenu! !
  1553.  
  1554. !SNARectangle methodsFor: 'initialize-release'!
  1555.  
  1556. initialize
  1557.     super initialize.
  1558.     centeredText _ #no.! !
  1559.  
  1560. Object subclass: #SEESharedStates
  1561.     instanceVariableNames: ''
  1562.     classVariableNames: 'BrushForm GridPoint '
  1563.     poolDictionaries: ''
  1564.     category: 'TestSNA-Lin'!
  1565.  
  1566. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  1567.  
  1568. SEESharedStates class
  1569.     instanceVariableNames: ''!
  1570.  
  1571.  
  1572. !SEESharedStates class methodsFor: 'access'!
  1573.  
  1574. brushForm
  1575.     "Shan April 3, 1990"
  1576.  
  1577.     BrushForm isNil ifTrue: [BrushForm _ (Form extent: 2@2) black].
  1578.     ^BrushForm!
  1579.  
  1580. brushForm: aForm
  1581.     "Shan April 3, 1990"
  1582.  
  1583.     BrushForm _ aForm!
  1584.  
  1585. gridPoint
  1586.     "Shan March 19, 1990"
  1587.  
  1588.     GridPoint isNil ifTrue: [GridPoint _ 10 @ 10].
  1589.     ^GridPoint!
  1590.  
  1591. gridPoint: pt
  1592.     "Shan March 19, 1990"
  1593.  
  1594.     GridPoint _ pt! !